COMMENT ⊗   VALID 00009 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	{$NOMAIN	Individual statement Interpreters }
C00005 00003	procedure doCase external
C00007 00004	procedure doCall external
C00008 00005	procedure doReturn external
C00012 00006	procedure doAssign external
C00014 00007	procedure doPrompt external
C00016 00008	procedure doSignal external
C00018 00009	procedure doWait external
C00020 ENDMK
C⊗;
{$NOMAIN	Individual statement Interpreters }

%include ialhdr.pas;

{ Externally defined routines: }

	(* From ALLOC *)
function newNode: nodep;					external;
procedure relNode(n: nodep);					external;

	(* From IAUX1A *)
function pop: nodep;						external;
function gtVarn (n: nodep): enventryp;				external;
procedure freePdb(p: pdbp);					external;
procedure killNode(n: nodep);					external;
procedure killStack;						external;

	(* From IAUX1B *)
procedure prntPlist(n: nodep);					external;
procedure prntVar(v: nodep);					external;
procedure addPdb(var plist: pdbp; pn: pdbp);			external;
procedure sleep(whenV: integer);				external;

	(* From IAUX2A *)
procedure killEnv;						external;
procedure setVal (level, offset: byte);				external;

	(* From IAUX2B *)
function cmonCheck: boolean;					external;

	(* From IROOT *)
procedure ov2FlushKids(p: pdbp; zapit: boolean);		external;

	(* Display-related Routines *)
procedure ppLine; 						external;
procedure ppOutNow; 						external;
procedure ppChar(ch: ascii); 					external;
procedure pp5(ch: c5str; length: integer); 			external;
procedure pp10(ch: cstring; length: integer); 			external;
procedure pp10L(ch: cstring; length: integer);			external;
procedure pp20(ch: c20str; length: integer); 			external;
procedure pp20L(ch: c20str; length: integer); 			external;
procedure ppInt(i: integer); 					external;
procedure ppReal(r: real); 					external;
procedure ppStrng(length: integer; s: strngp); 			external;


procedure iOv2Get; external;
procedure iOv2Get; begin end;
procedure doCase; external;
procedure doCase;
 var i: integer; p: nodep; spcp: statementp; b: boolean;
 begin
 with curInt↑ do
  begin
  p := pop;				(* pop index value off of stack *)
  i := round(p↑.s);
  relNode(p);
  spcp := nil;
  p := spc↑.caselist;
  if (i >= 0) and (i <= abs(spc↑.range)) then	(* index within range *)
    begin					(* try to find proper case *)
    b := true;
    while (p <> nil) and b do
     if (p↑.cval = i) then b := false else p := p↑.next;
    if p <> nil then
      begin spcp := p↑.stmnt; if spcp = nil then spcp := spc↑.next end
     else if spc↑.range >= 0 then spcp := spc↑.next (* null statement *)
    end;
  if (spcp = nil) and (spc↑.range < 0) then
    begin (* if none found and it's a labelled case statement check for else *)
    p := spc↑.caselist;
    b := true;
    while (p <> nil) and b do			(* search for else stmnt *)
     if (p↑.cval = -1) then b := false else p := p↑.next;
    if p <> nil then spcp := p↑.stmnt
    end;
  if spcp = nil then
    begin
    pp20L('Case index out of ra',20); pp5('nge: ',5); ppInt(i); ppLine;
    spcp := spc↑.next;
    end;
  spc := spcp;
  mode := 0;
  end;
 end;

procedure doCall; external;
procedure doCall;
 var n: nodep;
 begin
 with curInt↑ do
  begin
  if spc↑.what↑.arg1↑.vari↑.vtype <> nulltype then  (* flush unused result *)
    n := pop;
  mode := 0;
  spc := spc↑.next;	(* move on to next statement *);
  end;
 end;

procedure doReturn; external;
procedure doReturn;
 var p: pdbp; n: nodep; b,debRet: boolean; 
 begin
 b := true;
 with curInt↑ do
  begin
  if procp then debRet := false			(* normal case *)
   else if (priority > 9) and (nextpdb = nil) and (opdb <> nil) then
    debRet := true			(* immediately executed RETURN *)
   else b := false;			(* no good - nothing to return from *)
  if debRet then p := opdb↑.opdb else p := opdb;	(* pdb of caller *)
  if b then
    begin
    while b and not env↑.procp do
     begin	(* make sure all cmon's in outer environments have finished *)
     b := cmonCheck;
     if b then killEnv;		(* flush all environments out to parameters *)
     end;
    if b then			(* no cmons now running *)
      begin	(* now we can clean things up & return from the procedure *)
      if spc↑.retval <> nil then n := pop		(* get return value *)
       else n := nil;
      if env↑.proc↑.ptype <> nulltype then
	begin			(* yes - put return value on caller's stack *)
	if n <> nil then
	  if env↑.proc↑.ptype <> n↑.ltype then
	    begin
	    killNode(n);
	    n := nil;
	    end;
	if n = nil then
	  begin
	  n := newNode;
	  with n↑ do		(* use default value *)
	   begin
	   ntype := leafnode;
	   ltype := env↑.proc↑.ptype;	(* copy datatype of result *)
	   if ltype = svaltype then s := 0.0	(* it's a scalar *)
	    else if ltype = vectype then v := nilvect
	    else if ltype = transtype then t := niltrans
	    else begin length := 0; str := nil end;
	    end;
	  end;
	n↑.next := p↑.sp;
	p↑.sp := n;
	end;
      killEnv;				(* flush procedure's parameters too *)
      killStack;			(* flush stack *)
      if debRet then
	begin
	opdb↑.opdb↑.status := runqueue;
	addPdb(activeInts,opdb↑.opdb);	(* re-activate caller *)
	opdb↑.level := 255;		(* so we don't re-release environments *)
	ov2FlushKids(opdb,true);	(* flush old procedure's pdb *)
	spc := sdef↑.next;		(* point to our abort *)
	running := false;		(* and return to debugger *)
	end
       else
	begin
	freePdb(curInt);		(* flush procedure's pdb *)
	curInt := p;			(* all done - return *)
	curInt↑.status := nowrunning;
	end;
      end
     else sleep(30);			(* give cmons time to finish *)
    end
   else
    begin
    pp20L('Ignoring return     ',16); ppLine;
    if spc↑.retval <> nil then n := pop;	(* flush return value *)
    spc := spc↑.next;			(* just move on to next statement *)
    mode := 0;
    end;
  end;
 end;

procedure doAssign; external;
procedure doAssign;
 var ev: enventryp; res: nodep;
 begin
 with curInt↑.spc↑.what↑ do
  begin
  if ntype = leafnode then 
    with vari↑ do setVal(level,offset) (* store into simple variable *)
   else
    case op of		(* see what type of store we're to do *)
arefop:	    with arg1↑.vari↑ do setVal(level,offset); (* store into array var *)
deproachop: begin	  (* any subscripts & deproach value on stack *)
	    ev := gtVarn(curInt↑.spc↑.what);	  (* access variable *)
	    res := pop;			  (* get deproach value *)
	    (* check we've really got a frame? *)
	    ev↑.f↑.fdepr := res↑.t;	  (* store it away *)
	    relNode(res);
	    end;
tposop,
torientop:  begin
	    with arg1↑ do
	     if ntype = leafnode then 
		with vari↑ do setVal(level,offset) (* simple variable *)
	       else
		with arg1↑.vari↑ do setVal(level,offset);  (* array variable *)
	    end;
otherwise   {do nothing};
    end;
  curInt↑.mode := 0;
  curInt↑.spc := curInt↑.spc↑.next;	(* move on to next statement *);
  end;
 end;

procedure doPrompt; external;
procedure doPrompt;
 var ch: ascii; b: boolean;
 begin
 with curInt↑ do
  case mode of
1:  begin
    if readQueue = nil then b := true
     else b := (readQueue↑.priority div 10) < (curInt↑.priority div 10);
    if b then 
      begin			(* first time through *)
      prntplist(spc↑.plist);
      mode := 2;
      end
     else sleep(60)		(* wait a sec for other input to finish *)
    end;

2:  begin
    pp20L('Type P to proceed:  ',19);
    ppOutNow;
    mode := 3;
    curInt↑.next := readQueue;
    readQueue := curInt;			(* swap us out *)
    curInt↑.status := inputqueue;
    curInt := nil;
    inputp := 0;
    resched := true;
    end;

3:  begin
    inputReady := false;
    if (inputLine[1] = chr(160B)) or (inputLine[1] = 'P') then
      begin
      mode := 0;
      spc := spc↑.next;
      end
     else mode := 2;			(* try again *)
    end;

   end;
 end;

procedure doSignal; external;
procedure doSignal;
 var ev: enventryp; p, pt: pdbp; st: statementp;
 begin
 with curInt↑ do
  begin
  st := spc;
  spc := spc↑.next;	(* advance our pc now before possibly swapping ourself out *)
  mode := 0;
  if singleThreadMode then
    begin
    pp20L('Would signal event: ',20); prntVar(st↑.event);
    end
   else if st↑.event <> nil then
    begin
    ev := gtVarn(st↑.event);	(* access variable *)
    ev↑.evt↑.count := ev↑.evt↑.count + 1;
    p := ev↑.evt↑.waitlist;	(* get pdb of process to schedule (if any) *)
    if p <> nil then 
      begin
      ev↑.evt↑.waitlist := p↑.next;		(* remove node from waitlist *)
      if p↑.priority > priority then
	begin				(* swap it in and swap us out *)
	p↑.status := nowrunning;
	pt := curInt;
	curInt := p;
	p := pt;
	end;
      p↑.status := runqueue;
      addPdb(activeInts,p);		(* add whoever to active process list *)
      end;
    end;
  end;
 end;

procedure doWait; external;
procedure doWait;
 var ev: enventryp; p: pdbp; st: statementp; b: boolean;
 begin
 with curInt↑ do
  if singleThreadMode then
    if mode = 1 then
      begin
      if readQueue = nil then b := true
       else b := (readQueue↑.priority div 10) < (curInt↑.priority div 10);
      if b then 
	begin			(* first time through *)
	pp20L('Would wait for event',20); pp5(':    ',2); prntVar(spc↑.event);
	mode := 2;
	doPrompt;		(* now have user type a "P" to proceed *)
	end
       else sleep(60)		(* wait a sec for other input to finish *)
      end
     else doPrompt
   else
    begin
    st := spc;
    spc := spc↑.next;	(* advance our pc now before maybe swapping out *)
    mode := 0;
    if st↑.event <> nil then
      begin
      ev := gtVarn(st↑.event);		(* access variable *)
      ev↑.evt↑.count := ev↑.evt↑.count - 1;
      if ev↑.evt↑.count < 0 then 	(* hasn't been signalled yet, need to wait *)
	begin
	curInt↑.status := eventqueue;
	addPdb(ev↑.evt↑.waitlist,curInt);	(* add us to wait list *)
	curInt := nil;			(* swap in someone else *)
	resched := true;
	end;
      end;
    end;
 end;